(DEFPROP EDITOR (
	EDITOR
	ERRMSG0
	ERRMSG1
	ERRMSG-BAD-ARG
	ERRMSG-AT-THE-TOP
	ERRMSG-LEFT-EDGE
	ERRMSG-RIGHT-EDGE
	ERRMSG-CE-ATOMIC
	ERRMSG-EVAL-ERR
        EDITOR-DOWN 
	NTHELT
	NTHTAIL
	COPY
	CHOP
) EDITORFNS)

(DEFPROP EDITOR (
        TOP 
        UP
        LF
        RT
        RI
        RO
        LI
        RO
        P
) ATOMIC-EDIT-FNS)

(DEFPROP EDITOR (
	(I N X)
	(D N)
) LIST-EDIT-FNS)

(DEFUN EDITOR FEXPR (L)
  (PROG (FN TOP CE CHAIN COMMAND EFN)
    (COND ((NULL L)  (ERRMSG0) (RETURN 'NO-EDIT)))
    (SETQ FN (CAR L))
    (SETQ TOP (COPY (GET FN 'EXPR)))
    (COND ((NULL TOP)  (ERRMSG0) (RETURN 'NO-EDIT)))
    (SETQ CE TOP CHAIN NIL)
  EDLOOP
    (PRINT 'ε)
    (SETQ COMMAND (READ))
    (COND ((EQ COMMAND 'Q) (RETURN 'BYE) )
          ((EQ COMMAND 'OK) (RETURN (PUTPROP FN TOP 'EXPR)) )
          ((NUMBERP COMMAND) (EDITOR-DOWN COMMAND) (GO EDLOOP))
          ((AND (ATOM COMMAND) (SETQ EFN (GET COMMAND 'ATOMIC-EDIT-FN)))
           (EVAL EFN)
           (GO EDLOOP) )
          ((AND (NOT (ATOM COMMAND)) (SETQ EFN (GET (CAR COMMAND) 'LIST-EDIT-FN)))
           (APPLY EFN (CDR COMMAND))
           (GO EDLOOP)) )
    (SETQ EFN (ERRSET (EVAL COMMAND) NIL))
    (COND (EFN (PRINT (CAR EFN)))  (T (ERRMSG-EVAL-ERR)))
    (GO EDLOOP) )
   )


;;; ATOMIC-EDIT-FNS

(DEFPROP TOP ;;;
  (PROGN
    (SETQ CE TOP)
    (SETQ CHAIN NIL)
  )
ATOMIC-EDIT-FN)


(DEFPROP UP                      ;;;CE ← PARENT(CE)
    (COND ((NULL CHAIN) (ERRMSG-AT-THE-TOP))
          (T (SETQ CE (CDAR CHAIN))
             (SETQ CHAIN (CDR CHAIN)) )
     )
ATOMIC-EDIT-FN)

(DEFPROP RT ;;;MOVE RIGHT
  (PROG (N)
    (COND ((NULL CHAIN) (RETURN (ERRMSG-AT-THE-TOP))))
    (SETQ N (ADD1 (CAAR CHAIN)))
    (COND ((GREATERP N (LENGTH (CDAR CHAIN))) (RETURN (ERRMSG-RIGHT-EDGE))))
    (SETQ CE (NTHELT (CDAR CHAIN) N))
    (RPLACA (CAR CHAIN) N)
   )
ATOMIC-EDIT-FN)

(DEFPROP LF                              ;;;MOVE LEFT
  (PROG (N)
    (COND ((NULL CHAIN) (RETURN (ERRMSG-AT-THE-TOP))))
    (SETQ N (SUB1 (CAAR CHAIN)))
    (COND ((LESSP N 1) (RETURN (ERRMSG-LEFT-EDGE))))
    (SETQ CE (NTHELT (CDAR CHAIN) N))
    (RPLACA (CAR CHAIN) N)
   )
ATOMIC-EDIT-FN)

(DEFPROP LI                     ;;;MOVE LEFT PAREN IN 
  (PROG (POS)
    (COND ((NULL CHAIN) (RETURN (ERRMSG-AT-THE-TOP))))
    (COND ((ATOM CE) (RETURN (ERRMSG-CE-ATOMIC))))
    (SETQ POS (NTHTAIL (CDAR CHAIN) (CAAR CHAIN)))
    (RPLACA POS (CAR CE))
    (RPLACA CE (CDR CE))
    (RPLACD CE (CDR POS))
    (RPLACD POS CE)
    (SETQ CE (CAR CE))
    (RPLACA (CAR CHAIN) (ADD1 (CAAR CHAIN))) 
  )
ATOMIC-EDIT-FN)

(DEFPROP LO                     ;;;MOVE LEFT PAREN OUT
  (PROG (POS1 POS)
    (COND ((NULL CHAIN) (RETURN (ERRMSG-AT-THE-TOP))))
    (COND ((AND (ATOM CE) (NOT (NULL CE))) (RETURN (ERRMSG-CE-ATOMIC))))
    (SETQ N (SUB1 (CAAR CHAIN)))
    (COND ((LESSP N 1) (RETURN (ERRMSG-LEFT-EDGE))))
    (SETQ POS (NTHTAIL (CDAR CHAIN) N))
    (SETQ POS1 (CDR POS))
    (RPLACD POS (CDR POS1))
    (RPLACD POS1 CE)          
    (RPLACA POS1 (CAR POS))
    (RPLACA POS  POS1)
    (SETQ CE POS1)
    (RPLACA (CAR CHAIN) N) 
  )
ATOMIC-EDIT-FN)

(DEFPROP RI                       ;;;MOVE RIGHT PAREN IN 
  (PROG (LAST POS)
    (COND ((NULL CHAIN) (RETURN (ERRMSG-AT-THE-TOP))))
    (COND ((ATOM CE) (RETURN (ERRMSG-CE-ATOMIC))))

    (SETQ POS (NTHTAIL (CDAR CHAIN) (CAAR CHAIN)))

    (COND ((NULL (CDR CE)) 
           (RPLACA POS NIL) (SETQ LAST CE) (SETQ CE NIL) )
          (T (SETQ LAST (CHOP CE)) )   
          )
    (RPLACD LAST (CDR POS))
    (RPLACD POS LAST)
   )
ATOMIC-EDIT-FN)

(DEFPROP RO                     ;;;MOVE RIGHT PAREN OUT
  (PROG (POS POS1)
    (COND ((NULL CHAIN) (RETURN (ERRMSG-AT-THE-TOP))))
    (COND ((AND (ATOM CE) (NOT (NULL CE))) (RETURN (ERRMSG-CE-ATOMIC))))

    (SETQ POS (NTHTAIL (CDAR CHAIN) (CAAR CHAIN)))
    (SETQ POS1 (CDR POS))
    (COND ((NULL POS1) (RETURN (ERRMSG-RIGHT-EDGE))))

    (RPLACD POS (CDR POS1))
    (RPLACD POS1 NIL)
    (COND ((NULL CE) (RPLACA POS POS1) (SETQ  CE POS1))
          (T (NCONC CE POS1)))
  )
ATOMIC-EDIT-FN)


(DEFPROP P  ;;;PRINT THE CE
  (PRINT CE)
ATOMIC-EDIT-FN)

(DEFPROP B  ;;;BREAK
  (BREAK EDITOR T)
ATOMIC-EDIT-FN)

;;; LIST-EDIT-FNS


(DEFPROP D
  (LAMBDA (N)
    (COND ((OR (NOT (GREATERP N 0))
               (LESSP (LENGTH CE) N))
           (ERRMSG-BAD-ARG))
          ((EQ N 1)               ;;; RESET CE AND POINTERS TO IT
           (SETQ CE (CDR CE))
           (COND ((NULL CHAIN) (SETQ TOP CE))
                  (T (RPLACA (NTHTAIL (CDAR CHAIN) (CAAR CHAIN)) CE)) )
            )
          (T (RPLACD (NTHTAIL CE (SUB1 N)) (CDR (NTHTAIL CE N))))  )
    )
LIST-EDIT-FN)


(DEFPROP I                        ;;; Insert X at position N in CE
  (LAMBDA (N X)
    (PROG (TMP)
      (COND ((OR (NOT (GREATERP N 0))
                 (LESSP (LENGTH CE) (SUB1 N)))
             (RETURN (ERRMSG-BAD-ARG))))
      (SETQ TMP (CONS X (NTHTAIL CE N)))
      (COND ((EQ N 1)             ;;; RESET CE AND POINTERS TO IT
             (SETQ CE TMP)
	     (COND ((NULL CHAIN) (SETQ TOP CE))
		   (T (RPLACA (NTHTAIL (CDAR CHAIN) (CAAR CHAIN)) CE)) )
              )
            (T (RPLACD (NTHTAIL CE (SUB1 N)) TMP))
       )
     ))
LIST-EDIT-FN)

;;; AUXILIARY EDIT FNS

(DEFUN ERRMSG0 () (PRINT FN) (PRINC '| not an EXPR |))
(DEFUN ERRMSG1 () (PRINT COMMAND) (PRINC '| > length of CE |))
(DEFUN ERRMSG-BAD-ARG () (TERPRI) (PRINC '| Invalid position - Insert/Delete |))
(DEFUN ERRMSG-AT-THE-TOP () (TERPRI) (PRINC '| You are at the top |))
(DEFUN ERRMSG-LEFT-EDGE () (TERPRI) (PRINC '| You are at the left edge |))
(DEFUN ERRMSG-RIGHT-EDGE () (TERPRI) (PRINC '| You are at the right edge |))
(DEFUN ERRMSG-CE-ATOMIC () (TERPRI) (PRINC '| CE is atomic |))
(DEFUN ERRMSG-EVAL-ERR () (TERPRI) (PRINC '| EVAL error |))


(DEFUN EDITOR-DOWN (N)                ;;; CE←NTHELT(CE,N)
      (COND ((OR (ATOM CE) (GREATERP N (LENGTH CE))) (ERRMSG1))
            (T (SETQ CHAIN (CONS (CONS N CE) CHAIN))
               (SETQ CE (NTHELT CE N)) )
       ))

(DEFUN NTHELT (U N)   ;; U is non-empty list N≥1
  (COND ((AND (GREATERP N 1) (NOT (NULL (CDR U)))) (NTHELT (CDR U) (SUB1 N)))
	(T (CAR U)) ))

(DEFUN NTHTAIL (U N)   ;; U is non-empty list N≥1
  (COND ((AND (GREATERP N 1) (NOT (NULL (CDR U)))) (NTHTAIL (CDR U) (SUB1 N)))
	(T U) ))

(DEFUN COPY (X) (COND ((ATOM X) X) (T (CONS (COPY (CAR X)) (COPY (CDR X)))) ))


(DEFUN CHOP (U)  ;;len u ≥2
  (PROG (U1 U2)
    (SETQ U1 U)
  LOOP
    (SETQ U2 (CDR U1))
    (COND ((NULL (CDR U2)) (RPLACD U1 NIL) (RETURN U2)))
    (SETQ U1 U2)
    (GO LOOP) ))